(load "infix")
(defpackage :calcy
  (:use :cl))

(defun repl ()
  (catch 'exit
    (loop
     (format *query-io* "~&> ")
     (finish-output *query-io*)
     (let* ((input (read-line *query-io* nil nil))
	    (result (if (string= input "quit")
			(throw 'exit nil)
			(calcy-eval (format nil "~A~%" input)))))
       (format *query-io* "~A~%~%" result)))))

(defun calcy-eval (input)
  "Evaluate a calcy expression"
  (eval (infix::string->prefix input)))

;; RPN
;;;;;;

(defun translator (name scheme)
  "Returns that translator function named `name' for a given scheme"
  (get name scheme))

(defun (setf translator) (fun name scheme)
  (setf (get name scheme) fun))

(defmacro define-translator (name scheme args &body body)
  `(setf (translator ',name ',scheme)
    #'(lambda ,args
	,@body)))

(defun join (list &optional (delim " "))
  (with-output-to-string (stream)
    (loop for cons on list do
          (princ (car cons) stream)
          (when (cdr cons) (princ delim stream)))))

(defun n-repeats (n x)
  (loop for count below n
	collect x))

(defun basic-arithmetic-op-forth-translator (op)
  #'(lambda (stream &rest args)
      (princ (join (append args (n-repeats (1- (length args))
					   op)))
	     stream)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (translator '+ :forth) (basic-arithmetic-op-forth-translator '+))
  (setf (translator '- :forth) (basic-arithmetic-op-forth-translator '-))
  (setf (translator '* :forth) (basic-arithmetic-op-forth-translator '*))
  (setf (translator '/ :forth) (basic-arithmetic-op-forth-translator '/))
  (setf (get 'generic-function :forth)
	(lambda (fun)
	  (lambda (stream &rest args)
	    (princ (join (append args (list fun)))
		   stream)))))

(defun basic-arithmetic-op-infix-translator (op)
  #'(lambda (stream &rest args)
      (princ #\( stream)
      (princ (join args (format nil " ~A " op))
	     stream)
      (princ #\) stream)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (setf (translator '+ :infix) (basic-arithmetic-op-infix-translator '+))
  (setf (translator '- :infix) (basic-arithmetic-op-infix-translator '-))
  (setf (translator '* :infix) (basic-arithmetic-op-infix-translator '*))
  (setf (translator '/ :infix) (basic-arithmetic-op-infix-translator '/))
  (setf (get 'generic-function :infix)
      (lambda (fun)
	(lambda (stream &rest args)
	  (format stream "~A(~A)"
		  fun
		  (join args ", "))))))

(defun translate (expr scheme)
  (with-output-to-string (stream)
    (etypecase expr
      ((or number symbol)
       (princ expr stream))
      (list
       (let* ((fun (car expr))
	      (args (cdr expr))
	      (translator (or (translator fun scheme)
			      (let ((translator (get 'generic-function scheme)))
				(when translator
				  (funcall translator fun)))
			      (error "Translator for ~A not found, and a generic function translator was not found for this scheme"
				     fun))))
	 (apply translator stream
		(mapcar #'(lambda (expr)
			    (translate expr scheme))
			args)))))))